home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / PROGTOOL / LIB211.ZIP;1 / STRINGS.PRG < prev    next >
Encoding:
Text File  |  1993-11-23  |  72.2 KB  |  1,960 lines
  1. *----------------------------------------------------------------------
  2. *-- Program...: STRINGS.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030)
  4. *-- Date......: 08/02/1993
  5. *-- Notes.....: String manipulation routines -- These routines are all
  6. *--             designed to handle the processing of "Strings"
  7. *--             (Character Strings). They range from simple checking of
  8. *--             the location of a string inside another, to reversing
  9. *--             the contents of a string ... and lots more. See the
  10. *--             file: README.TXT for details on use of this (and the
  11. *--             other) library file(s).
  12. *----------------------------------------------------------------------
  13.  
  14. FUNCTION Proper
  15. *----------------------------------------------------------------------
  16. *-- Programmer..: Clinton L. Warren (VBCES)
  17. *-- Date........: 07/10/1991
  18. *-- Notes.......: Returns cBaseStr converted to proper case.  Converts
  19. *--               "Mc", "Mac", and "'s" as special cases.  Inspired by
  20. *--               A-T's CCB Proper function.  cBaseStr isn't modified.
  21. *-- Written for.: dBASE IV, 1.1
  22. *-- Rev. History: 07/10/1991 1.0 - Original version (VBCES/CLW)
  23. *-- Calls.......: None
  24. *-- Called by...: Any
  25. *-- Usage.......: Proper(<cBaseStr>)
  26. *-- Example.....: Proper("mcdonald's") returns "McDonald's"
  27. *-- Returns.....: Propertized string (e.g. "Test String")
  28. *-- Parameters..: cBaseStr = String to be propertized
  29. *----------------------------------------------------------------------
  30.  
  31.    PARAMETERS cBaseStr
  32.    private nPos, cDeli, cWrkStr
  33.  
  34.    cWrkStr = lower(m->cBaseStr) + ' ' && space necessary for 's process
  35.  
  36.    nPos = at('mc', m->cWrkStr)        && "Mc" handling
  37.    do while nPos # 0
  38.       cWrkStr = stuff(m->cWrkStr, m->nPos, 3, ;
  39.                   upper(substr(m->cWrkStr, m->nPos, 1)) ;
  40.                 + lower(substr(m->cWrkStr, m->nPos + 1, 1)) ;
  41.                 + upper(substr(m->cWrkStr, m->nPos + 2, 1)))
  42.       nPos = at('mc', m->cWrkStr)
  43.    enddo
  44.  
  45.    nPos = at('mac', m->cWrkStr)       && "Mac" handling
  46.    do while nPos # 0
  47.       cWrkStr = stuff(m->cWrkStr, m->nPos, 4, ;
  48.                     upper(substr(m->cWrkStr, m->nPos, 1)) ;
  49.                   + lower(substr(m->cWrkStr, m->nPos + 1, 2)) ;
  50.                   + upper(substr(m->cWrkStr, m->nPos + 3, 1)))
  51.       nPos = at('mac', m->cWrkStr)
  52.    enddo
  53.  
  54.    cWrkStr = stuff(m->cWrkStr, 1, 1, upper(substr(m->cWrkStr, 1, 1)))
  55.    nPos = 2
  56.    cDeli = [ -.'"\/`]                           && standard delimiters
  57.  
  58.    do while nPos <= len(m->cWrkStr)             && 'routine' processing
  59.       if substr(m->cWrkStr,m->nPos-1,1) $ m->cDeli
  60.          cWrkStr = stuff(m->cWrkStr, m->nPos, 1, ;
  61.                    upper(substr(m->cWrkStr,m->nPos,1)))
  62.       endif
  63.       nPos = m->nPos + 1
  64.    enddo
  65.  
  66.    nPos = at("'S ", m->cWrkStr)                 && 's processing
  67.    do while m->nPos # 0
  68.       cWrkStr = stuff(m->cWrkStr, m->nPos, 2, ;
  69.                 lower(substr(m->cWrkStr, m->nPos, 2)))
  70.       nPos = at('mac', m->cWrkStr)
  71.    enddo
  72.  
  73. RETURN (m->cWrkStr)
  74. *-- EoF: Proper()
  75.  
  76. FUNCTION Dots
  77. *----------------------------------------------------------------------
  78. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  79. *-- Date........: 12/17/1991
  80. *-- Notes.......: Based on ideas from Technotes, June, 1990 (see
  81. *--               JUSTIFY() ), this function should pad a field or
  82. *--               memvar with dots to the left, right or both sides.
  83. *--               Note that if the field is too large for the length
  84. *--               passed (nLength) it will be truncated.
  85. *-- Written for.: dBASE IV, 1.1
  86. *-- Rev. History: 12/17/1991 -- Original
  87. *-- Calls.......: ALLTRIM()            Function in PROC.PRG
  88. *-- Called by...: Any
  89. *-- Usage.......: Dots(<cFld>,<nLength>,"<cType>")
  90. *-- Example.....: ?? Dots(Address,25,"R")
  91. *-- Returns.....: Field/memvar with dot leader/trailer ...
  92. *-- Parameters..: cFld    = Field/Memvar/Character String to justify
  93. *--               nLength = Width to justify within
  94. *--               cType   = Justification: L=Left, C=Center,R=Right
  95. *----------------------------------------------------------------------
  96.   
  97.    parameters cFld,nLength,cType
  98.    private cReturn, nVal, nMore
  99.  
  100.    if type("cFld")+type("nLength")+type("cType") $ "CNC,CFC"
  101.  
  102.       cType   = upper(m->cType)      && just to make sure ...
  103.       cReturn = AllTrim(m->cFld)     && trim this puppy on all sides
  104.       if len(cReturn) => m->nLength  && check length against parameter
  105.                                      && truncate if necessary
  106.          cReturn = substr(m->cReturn,1,m->nLength)
  107.       endif
  108.  
  109.       do case
  110.          case cType = "L"  && Left -- add trailing dots to field
  111.             cReturn = m->cReturn + ;
  112.                       replicate(".",m->nLength-len(m->cReturn))
  113.          case cType = "R"  && Right -- add leading dots to field
  114.             cReturn = replicate(".",m->nLength-len(m->cReturn)) + ;
  115.                       m->cReturn
  116.          case cType = "C"  && Center -- add 'em to both sides ...
  117.             nVal = int( (m->nLength - len(m->cReturn)) / 2)
  118.             *-- here, we have to deal with fractions ...
  119.             nMore = mod(m->nlength - len(m->cReturn), 2)
  120.             *-- add dots on left, field, dots on right (+1 if fraction)
  121.             cReturn = replicate(".",m->nVal)+m->cReturn+;
  122.                       replicate(".",m->nVal+iif(m->nMore>0,1,0))
  123.          otherwise         && invalid parameter ... return nothing
  124.             cReturn = ""
  125.       endcase
  126.    else
  127.       cReturn = ""
  128.    endif
  129.  
  130. RETURN m->cReturn
  131. *-- EoF: Dots()
  132.  
  133. FUNCTION CutPaste
  134. *----------------------------------------------------------------------
  135. *-- Programmer..: Martin Leon (HMAN)
  136. *-- Date........: 03/05/1992
  137. *-- Notes.......: Used to do a cut and paste within a field/character
  138. *--               string. (Taken from an issue of Technotes, can't
  139. *--               remember which) This function will not allow you to
  140. *--               overflow the field/char string -- i.e., if the Paste
  141. *--               part of the function would cause the returned field
  142. *--               to be longer than it started out, it will not perform
  143. *--               the cut/paste (STUFF()). For example, if your field
  144. *--               were 15 characters, and you wanted to replace 5 of
  145. *--               them with a 10 character string:
  146. *--                      (CutPaste(field,"12345","1234567890"))
  147. *--               If this would cause the field returned to be longer
  148. *--               than 15, the function will return the original field.
  149. *-- Written for.: dBASE IV, 1.1
  150. *-- Rev. History: Original function 12/17/1991
  151. *--               03/05/1992 -- minor change to TRIM(cFLD) in the early
  152. *--               bits, solving a minor problem with phone numbers that
  153. *--               Dave Creek (DCREEK) discovered.
  154. *-- Calls.......: None
  155. *-- Called by...: Any
  156. *-- Usage.......: CutPaste(<cFld>,"<cLookFor>","<cRepWith>")
  157. *-- Example.....: Replace all city with ;
  158. *--                   CutPaste(City,"L.A.","Los Angeles")
  159. *-- Returns.....: Field with text replaced (or not, if no match found)
  160. *-- Parameters..: cFld     = Field/Memvar/Expression to replace in 
  161. *--               cLookFor = Item to look for (Cut)
  162. *--               cRepWith = What to replace it with (Paste)
  163. *----------------------------------------------------------------------
  164.  
  165.    parameters cFld,cLookFor,cRepWith
  166.    private lMatched,nLookLen,nLen,nRepLen,cRetFld,nTrimLen,nCutAt
  167.  
  168.    *-- Make sure they're all character fields/strings
  169.    if type("cFld")+type("cLookFor")+type("cRepWith") # "CCC"
  170.       RETURN m->cFld
  171.    endif
  172.  
  173.    lMatched = .f.
  174.    nLookLen = len(m->cLookFor)  && length of field to look for
  175.    nLen     = len(m->cFld)      && length of original field
  176.    nRepLen  = len(m->cRepWith)  && length of field to replace with
  177.    cRetFld  = trim(m->cFld)     && trim it ... (DCREEK's suggestion)
  178.  
  179.    *-- loop will allow a cut/paste to occur more than once in the field
  180.    do while at(m->cLookFor,m->cRetFld) > 0
  181.       lMatched = .t.
  182.       cRetFld  = trim(m->cRetFld)
  183.       nTrimLen = len(m->cRetFld)
  184.  
  185.       *-- the following IF statement prevents the replacement text
  186.       *-- from overflowing the length of the original string ...
  187.       if(m->nTrimLen - m->nLookLen) + m->nRepLen > m->nLen
  188.          RETURN m->cRetFld
  189.       endif
  190.  
  191.       *-- here we figure where to "cut" at
  192.       nCutAt = at(m->cLookFor,m->cRetFld)
  193.       *-- let's do the paste ... (using dBASE STUFF() function)
  194.       cRetFld = stuff(m->cRetFld,m->nCutAt,m->nLookLen,m->cRepWith)
  195.    enddo
  196.  
  197.    if .not. lMatched  && no match with cLookFor, return original field
  198.       RETURN m->cFld
  199.    endif
  200.  
  201. RETURN m->cRetFld
  202. *-- EoF: CutPaste
  203.  
  204. FUNCTION LastWord
  205. *----------------------------------------------------------------------
  206. *-- Programmer..: Martin Leon (HMAN)
  207. *-- Date........: 12/19/1991
  208. *-- Notes.......: Returns the last word in a character string.
  209. *-- Written for.: dBASE IV, 1.1
  210. *-- Rev. History: 12/19/1991 -- Original
  211. *-- Calls.......: None
  212. *-- Called by...: Any
  213. *-- Usage.......: LastWord("<cString>")
  214. *-- Example.....: ? LastWord("This is a test string") 
  215. *-- Returns.....: The Last word (bracketed with spaces), i.e.:"string"
  216. *-- Parameters..: cString = string to be searched 
  217. *----------------------------------------------------------------------
  218.   
  219.    parameters cString
  220.    private cReturn
  221.  
  222.    cReturn = trim(m->cString)
  223.    do while at(" ",m->cReturn) # 0
  224.       cReturn = substr(m->cReturn,at(" ",m->cReturn)+1)
  225.    enddo
  226.  
  227. RETURN m->cReturn
  228. *-- EoF: LastWord()
  229.  
  230. FUNCTION VStretch
  231. *----------------------------------------------------------------------
  232. *-- Programmer..: Martin Leon (HMAN -- Ashton Tate/Borland BBS)
  233. *-- Date........: 10/30/91
  234. *-- Notes.......: Used to display a long character field, with proper
  235. *--               word wrap
  236. *-- Written for.: dBASE IV, 1.1
  237. *-- Rev. History: Once upon a time, Martin helped me write a more
  238. *--               complicated routine for use in a browse table. He
  239. *--               came up with this much less complex version recently
  240. *--               and sent to me via EMail.
  241. *--               (10/30/1991 -- Original release for the library)
  242. *-- Calls.......: None
  243. *-- Called by...: Any
  244. *-- Usage.......: ? VStretch( <cLFld>,<nULRow>,<nULCol>,;
  245. *--                                   <nBRRow>,<nBRCol> )
  246. *-- Example.....: ? VStretch( Notes,20,10,24,60,"rg+/gb" )
  247. *-- Returns.....: ""  (Nul)
  248. *-- Parameters..: cLFld  = Long Field to be wrapped on screen
  249. *--               nULRow = Upper Left Row of window
  250. *--               nULCol = Upper Left Column
  251. *--               nBRRow = Bottom Right Row of window
  252. *--               nBRCol = Bottom Right Column
  253. *----------------------------------------------------------------------
  254.  
  255.    parameter cLFld,nULRow,nULCol,nBRRow,nBRCol
  256.    private nWinWidth
  257.  
  258.    nWinWidth = ltrim(str((m->nBRCol - m->nULCol)-1,2))
  259.    *-- define window without any border ...
  260.    define window wStretch from m->nULRow,m->nULCol to ;
  261.                                m->nBRRow,m->nBRCol none
  262.    activate window wStretch
  263.    *-- make sure window is empty ...
  264.    clear
  265.    *-- display field
  266.    ?? m->cLFld picture "@V"+m->nWinWidth at 0  && @V = word wrap
  267.    save screen to sTemp
  268.    activate screen
  269.    release window wStretch
  270.    restore screen from sTemp
  271.    release screen sTemp
  272.  
  273. RETURN ""
  274. *-- EoF: VStretch()
  275.  
  276. FUNCTION AtCount
  277. *----------------------------------------------------------------------
  278. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  279. *-- Date........: 03/01/1992
  280. *-- Notes.......: Get number of times FindString occurs in Bigstring
  281. *-- Written for.: dBASE IV
  282. *-- Rev. History: 03/01/1992 -- Original Release
  283. *-- Calls.......: None
  284. *-- Called by...: Any
  285. *-- Usage.......: AtCount("<cFindStr>","<cBigStr>")
  286. *-- Example.....: ? AtCount("Test","This Test string has Test data")
  287. *-- Returns.....: Numeric value
  288. *-- Parameters..: cFindStr = string to find in cBigStr
  289. *--               cBigStr  = string to look in
  290. *----------------------------------------------------------------------
  291.  
  292.    parameters cFindstr, cBigstr
  293.    private cTarget, nCount
  294.  
  295.    cTarget = m->cBigstr
  296.    nCount = 0
  297.  
  298.    do while .t.
  299.       if at( m->cFindStr,m->cTarget ) > 0
  300.          nCount = m->nCount + 1
  301.          cTarget = substr(m->cTarget, at( m->cFindstr,m->cTarget ) + 1)
  302.       else
  303.          exit
  304.       endif
  305.    enddo
  306.  
  307. RETURN m->nCount
  308. *-- EoF: AtCount()
  309.         
  310. FUNCTION IsAlNum
  311. *----------------------------------------------------------------------
  312. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  313. *-- Date........: 03/01/1992
  314. *-- Notes.......: Returns .T. if the first character of cChar is
  315. *--               alphanumeric, otherwise it is false.
  316. *-- Written for.: dBASE IV
  317. *-- Rev. History: 03/01/1992 -- Original Release
  318. *-- Calls.......: None
  319. *-- Called by...: Any
  320. *-- Usage.......: IsAlNum("<cChar>")
  321. *-- Example.....: ? IsAlNum("Test")
  322. *-- Returns.....: Logical
  323. *-- Parameters..: cChar = character string to check for Alphanumeric
  324. *----------------------------------------------------------------------
  325.  
  326.    parameters cChar
  327.  
  328. RETURN isalpha( m->cChar ) .or. left( m->cChar, 1 ) $ "0123456789"
  329. *-- EoF: IsAlNum()
  330.  
  331. FUNCTION IsAscii
  332. *----------------------------------------------------------------------
  333. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  334. *-- Date........: 03/01/1992
  335. *-- Notes.......: Returns .t. if the first character of cChar is in the
  336. *--               lower half of the ASCII set ( value < 128 )
  337. *-- Written for.: dBASE IV
  338. *-- Rev. History: 03/01/1992 -- Original Release
  339. *-- Calls.......: None
  340. *-- Called by...: Any
  341. *-- Usage.......: IsAscii("<cChar>")
  342. *-- Example.....: ? IsAscii("Teststring")
  343. *-- Returns.....: Logical
  344. *-- Parameters..: cChar = string to test
  345. *----------------------------------------------------------------------
  346.  
  347.    parameters cChar
  348.  
  349. RETURN asc( m->cChar ) < 128
  350. *-- EoF: IsAscii()
  351.  
  352. FUNCTION IsCntrl
  353. *----------------------------------------------------------------------
  354. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  355. *-- Date........: 03/01/1992
  356. *-- Notes.......: Returns .t. if the first character of cChar is a
  357. *--               delete, or a control character.
  358. *-- Written for.: dBASE IV
  359. *-- Rev. History: 03/01/1992 -- Original Release
  360. *-- Calls.......: None
  361. *-- Called by...: Any
  362. *-- Usage.......: IsCntrl("<cChar>")
  363. *-- Example.....: ? IsCntrl("Test")
  364. *-- Returns.....: Logical
  365. *-- Parameters..: cChar = string to test
  366. *----------------------------------------------------------------------
  367.  
  368.    parameters cChar
  369.    private nCharval
  370.  
  371.    nCharval = asc(cChar)
  372.  
  373. RETURN m->nCharval = 127 .or. m->nCharval < 32
  374. *-- EoF: IsCntrl()
  375.  
  376. FUNCTION IsDigit
  377. *----------------------------------------------------------------------
  378. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  379. *-- Date........: 03/01/1992
  380. *-- Notes.......: test to see if first character of cChar is a digit
  381. *-- Written for.: dBASE IV
  382. *-- Rev. History: 03/01/1992 -- Original Release
  383. *-- Calls.......: None
  384. *-- Called by...: Any
  385. *-- Usage.......: IsDigit("<cChar>")
  386. *-- Example.....: ? IsDigit("123Test")
  387. *-- Returns.....: Logical, .T. if first character is a digit
  388. *-- Parameters..: cChar = string to test
  389. *----------------------------------------------------------------------
  390.  
  391.    parameters cChar
  392.  
  393. RETURN left( m->cChar, 1 ) $ "0123456789"
  394. *-- EoF: IsDigit()
  395.  
  396. FUNCTION IsPrint
  397. *----------------------------------------------------------------------
  398. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  399. *-- Date........: 03/01/1992
  400. *-- Notes.......: Returns .t. if first character of cChar is a printing 
  401. *--               character (space through chr(126) ).
  402. *-- Written for.: dBASE IV
  403. *-- Rev. History: Original Release
  404. *-- Calls.......: None
  405. *-- Called by...: Any
  406. *-- Usage.......: IsPrint("<cChar>")
  407. *-- Example.....: ? IsPrint("Test")
  408. *-- Returns.....: Logical
  409. *-- Parameters..: cChar = string to test
  410. *----------------------------------------------------------------------
  411.  
  412.    parameters cChar
  413.    private nCharval
  414.  
  415.    nCharval = asc(cChar)
  416.  
  417. RETURN m->nCharval > 31 .and. m->nCharval < 127
  418. *-- EoF: IsPrint()
  419.  
  420. FUNCTION IsXDigit
  421. *----------------------------------------------------------------------
  422. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  423. *-- Date........: 03/01/1992
  424. *-- Notes.......: Returns .t. if first character of cChar is a possible
  425. *--               hexidecimal digit.
  426. *-- Written for.: dBASE IV
  427. *-- Rev. History: 03/01/1992 -- Original Release
  428. *-- Calls.......: None
  429. *-- Called by...: Any
  430. *-- Usage.......: IsXDigit("<cChar>")
  431. *-- Example.....: ? IsXDigit("F000")
  432. *-- Returns.....: Logical
  433. *-- Parameters..: cChar = string to test
  434. *----------------------------------------------------------------------
  435.  
  436.    parameters cChar
  437.  
  438. RETURN left( m->cChar, 1 ) $ "0123456789ABCDEFabcdef"
  439. *-- EoF: IsXDigit()
  440.  
  441. FUNCTION IsSpace
  442. *----------------------------------------------------------------------
  443. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  444. *-- Date........: 03/01/1992
  445. *-- Notes.......: Returns .T. if first character of cChar is in set of
  446. *--               space, tab, carriage return, line feed, vertical tab
  447. *--               or formfeed, otherwise .F.  Differs from C function
  448. *--               of the same name in treating chr(141), used as
  449. *--               carriage return in dBASE memo fields, as a space.
  450. *-- Written for.: dBASE IV
  451. *-- Rev. History: Original Release
  452. *-- Calls.......: None
  453. *-- Called by...: Any
  454. *-- Usage.......: IsSpace("<cChar>")
  455. *-- Example.....: ? IsSpace(" Test")
  456. *-- Returns.....: Logical
  457. *-- Parameters..: cChar = string to test
  458. *----------------------------------------------------------------------
  459.  
  460.    parameters cChar
  461.    private cSpacestr
  462.  
  463.    cSpacestr = " "+chr(9)+chr(10)+chr(11)+chr(12)+chr(13)+chr(141)
  464.  
  465. RETURN left( m->cChar, 1 ) $ m->cSpacestr
  466. *-- EoF: IsSpace()
  467.  
  468. FUNCTION Name2Label
  469. *----------------------------------------------------------------------
  470. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  471. *-- Date........: 03/01/1992
  472. *-- Notes.......: Returns a name held in five separate fields or
  473. *--               memvars as it should appear on a label of a given
  474. *--               length in characters. The order of abbreviating is
  475. *--               somewhat arbitrary--you may prefer to remove the
  476. *--               suffix before the prefix, or to remove both before
  477. *--               abbreviating the first name.  This can be
  478. *--               accomplished by rearranging the CASE statements,
  479. *--               which operate in the order of their appearance.
  480. *-- Written for.: dBASE IV
  481. *-- Rev. History: 03/01/1992 -- Original Release
  482. *-- Calls.......: None
  483. *-- Called by...: Any
  484. *-- Usage.......: Name2Label(<nLength>,"<cPrefix>","<cFirstName>",;
  485. *--                          "<cMidName>","<cLastName>","<cSuffix>")
  486. *-- Example.....: ? Name2Label(20,"The Rev.","Elmore","Norbert",;
  487. *--                          "Smedley","III")
  488. *-- Returns.....: Character String, in this case "E. N. Smedley, III"
  489. *-- Parameters..: nLength     = length of label
  490. *--               cPrefix     = Prefix to name, such as Mr., Ms., Dr...
  491. *--               cFirstName  = self explanatory
  492. *--               cMiddleName = self explanatory
  493. *--               cLastName   = self explanatory
  494. *--               cSuffix     = "Jr.", "M.D.", "PhD", etc.
  495. *----------------------------------------------------------------------
  496.  
  497.    parameters nLength, cPrefix, cFirstname, cMidname, cLastname,cSuffix
  498.    private cTrypref, cTryfirst, cTrymid, cTrylast, cTrysuff, cTryname
  499.  
  500.    cTrypref  = ltrim( trim( m->cPrefix ) )
  501.    cTryfirst = ltrim( trim( m->cFirstname ) )
  502.    cTrymid   = ltrim( trim( m->cMidname ) )
  503.    cTrylast  = ltrim( trim( m->cLastname ) )
  504.    cTrysuff  = ltrim( trim( m->cSuffix ) )
  505.    do while .t.
  506.       cTryname = m->cTrylast
  507.       if "" # m->cTrymid
  508.          cTryname = m->cTrymid + " " + m->cTryname
  509.       endif
  510.       if "" # m->cTryfirst
  511.          cTryname = m->cTryfirst + " " + m->cTryname
  512.       endif
  513.       if "" # m->cTrypref
  514.          cTryname = m->cTrypref + " " + m->cTryname
  515.       endif
  516.       if "" # m->cTrysuff
  517.          cTryname = m->cTryname + ", " + m->cTrysuff
  518.       endif
  519.       if len(m->cTryname) <= m->nLength
  520.          exit
  521.       endif
  522.       do case
  523.          case "" # m->cTrymid .AND. right( m->cTrymid, 1 ) # "."
  524.             && convert middle name to initial
  525.             cTrymid = left( m->cTrymid, 1 ) + "."
  526.          case "" # m->cTryfirst .AND. right( m->cTryfirst, 1 ) # "."
  527.             && convert first name to initial
  528.             cTryfirst = left( m->cTryfirst, 1 ) + "."
  529.          case "" # m->cTrypref
  530.             cTrypref = ""                         && drop prefix
  531.           case "" # m->cTrysuff            
  532.             cTrysuff = ""                         && drop suffix
  533.           case "" # m->cTrymid                
  534.             cTrymid = ""                          && drop middle initial
  535.          case "" # m->cTryfirst
  536.             cTryfirst = ""                        && drop first initial
  537.          otherwise
  538.             && truncate last name
  539.             cTrylast = left( m->cTrylast, m->nLength )
  540.       endcase
  541.    enddo
  542.  
  543. RETURN m->cTryName
  544. *-- EoF: Name2Label()
  545.  
  546. FUNCTION StrPBrk
  547. *----------------------------------------------------------------------
  548. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  549. *-- Date........: 03/01/1992
  550. *-- Notes.......: Search string for first occurrence of any of the
  551. *--               characters in charset.  Returns its position as
  552. *--               with at().  Contrary to ANSI.C definition, returns
  553. *--               0 if none of characters is found.
  554. *-- Written for.: dBASE IV
  555. *-- Rev. History: 03/01/1992
  556. *-- Calls.......: None
  557. *-- Called by...: Any
  558. *-- Usage.......: StrPBrk("<cCharSet>","<cBigStr>")
  559. *-- Example.....: ? StrPBrk("Test","This Test string has Test data")
  560. *-- Returns.....: Numeric value
  561. *-- Parameters..: cCharSet = characters to look for in cBigStr
  562. *--               cBigStr  = string to look in
  563. *----------------------------------------------------------------------
  564.  
  565.    parameters cCharset, cBigstring
  566.    private nPos, nLooklen
  567.  
  568.    nPos = 0
  569.    nLooklen = len( m->cBigstring )
  570.    do while m->nPos < m->nLooklen
  571.       nPos = m->nPos + 1
  572.       if at( substr( m->cBigstring, m->nPos, 1 ), m->cCharset ) > 0
  573.          exit
  574.       endif
  575.    enddo
  576.  
  577. RETURN iif(nPos=m->nLookLen, 0, m->nPos)
  578. *-- EoF: StrPBrk()
  579.  
  580. FUNCTION StrRev
  581. *----------------------------------------------------------------------
  582. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  583. *-- Date........: 03/01/1992
  584. *-- Notes.......: Reverses a string of characters
  585. *-- Written for.: dBASE IV
  586. *-- Rev. History: 03/01/1992 -- Original Release
  587. *-- Calls.......: None
  588. *-- Called by...: Any
  589. *-- Usage.......: StrRev("<cAnyStr>")
  590. *-- Example.....: ? StrRev("This is a Test")
  591. *-- Returns.....: Character string, reversed from original input
  592. *-- Parameters..: cAnyStr = String of characters to reverse ...
  593. *----------------------------------------------------------------------
  594.  
  595.    parameters cAnystr
  596.    private cRevstring, nX,nY
  597.  
  598.    nX = len( m->cAnystr )
  599.    nY = 1
  600.    cRevstring = space( m->nX )
  601.    do while m->nX > 0
  602.           cRevstring = stuff(m->cRevstring, m->nY, 1, ;
  603.                        substr(m->cAnyStr,m->nX,1))
  604.      nY = m->nY + 1
  605.      nX = m->nX - 1
  606.    enddo
  607.  
  608. RETURN m->cRevstring
  609. *-- EoF: StrRev()
  610.  
  611. FUNCTION Strip2Val
  612. *----------------------------------------------------------------------
  613. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  614. *-- Date........: 03/01/1992
  615. *-- Notes.......: Strip characters from the left of a string until
  616. *--               reaching one that might start a number.
  617. *-- Written for.: dBASE IV
  618. *-- Rev. History: 03/01/1992 -- Original Release
  619. *-- Calls.......: None
  620. *-- Called by...: Any
  621. *-- Usage.......: Strip2Val("<cStr>")
  622. *-- Example.....: ? Strip2Val("Test345")
  623. *-- Returns.....: character string
  624. *-- Parameters..: cStr = string to search
  625. *----------------------------------------------------------------------
  626.  
  627.    parameters cStr
  628.    private cNew
  629.  
  630.    cNew = m->cStr
  631.    do while "" # m->cNew
  632.       if left( m->cNew, 1 ) $ "-.0123456789"
  633.          exit
  634.       endif
  635.       cNew = substr( m->cNew, 2 )
  636.    enddo
  637.  
  638. RETURN m->cNew
  639. *-- EoF: Strip2Val()
  640.  
  641. FUNCTION StripVal
  642. *----------------------------------------------------------------------
  643. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  644. *-- Date........: 03/01/1992
  645. *-- Notes.......: Strip characters from the left of the string until
  646. *--               reaching one that is not part of a number.  A hyphen
  647. *--               following numerics, or a second period,
  648. *--               is treated as not part of a number.
  649. *-- Written for.: dBASE IV
  650. *-- Rev. History: 03/01/1992 -- Original Release
  651. *-- Calls.......: None
  652. *-- Called by...: Any
  653. *-- Usage.......: StripVal("<cStr>")
  654. *-- Example.....: ? StripVal("123.2Test")
  655. *-- Returns.....: Character
  656. *-- Parameters..: cStr = string to test
  657. *----------------------------------------------------------------------
  658.  
  659.    parameters cStr
  660.    private cNew, cChar, lGotminus, lGotdot
  661.  
  662.    cNew = m->cStr
  663.    store .f. to lGotminus, lGotdot
  664.    do while "" # m->cNew
  665.       cChar = left( m->cNew, 1 )
  666.       do case
  667.        case .not. m->cChar $ "-.0123456789"
  668.           exit
  669.        case m->cChar = "-"
  670.           if m->lGotminus
  671.              exit
  672.           endif
  673.         case m->cChar = "."
  674.           if m->lGotdot
  675.              exit
  676.           else
  677.              lGotdot = .T.
  678.           endif
  679.       endcase
  680.       cNew = substr( m->cNew, 2 )
  681.       lGotminus = .T.
  682.    enddo
  683.  
  684. RETURN m->cNew
  685. *-- EoF: StripVal()
  686.  
  687. FUNCTION ParseWord
  688. *----------------------------------------------------------------------
  689. *-- Programmer..: Jay Parsons (CIS: 72662,1302).
  690. *-- Date........: 07/18/1993
  691. *-- Notes.......: returns the first word of a string
  692. *-- Written for.: dBASE IV, 1.1, 1.5
  693. *-- Rev. History: 04/26/1992 -- Original Release
  694. *--               07/18/1993  Add optional separator (Angus Scott-
  695. *--                           Fleming)
  696. *-- Calls       : None
  697. *-- Called by...: Any
  698. *-- Usage.......: ? ParseWord(<cString>,[<cSeparator>])
  699. *-- Example.....: Command = ParseWord( cProgramline )
  700. *-- Returns.....: That portion, trimmed on both ends, of the passed 
  701. *--               string that includes the characters up to the first 
  702. *--               interior word-separator.
  703. *-- Parameters..: cString - character string to be stripped.
  704. *--               cSeparator - optional separating character (default
  705. *--                            is " ")
  706. *----------------------------------------------------------------------
  707.  
  708.    parameters string, separator
  709.  
  710.    if .not.(type("separator") = "C" .and. len(m->separator)=1)
  711.       separator = " "
  712.    endif
  713.    private cW
  714.    cW = trim( ltrim( m->string ) )
  715.  
  716. RETURN iif( m->separator $ m->cW, ;
  717.           rtrim(left( m->cW, at( m->separator, m->cW ) - 1 )), m->cW )
  718. *-- EoF: ParseWord()
  719.  
  720. FUNCTION StripWord
  721. *----------------------------------------------------------------------
  722. *-- Programmer..: Jay Parsons (CIS: 72662,1302).
  723. *-- Date........: 07/18/1993
  724. *-- Notes.......: discards first word of a string
  725. *-- Written for.: dBASE IV, 1.1, 1.5
  726. *-- Rev. History: 04/26/1992 -- Original Release
  727. *--               07/18/1993  Add optional separator (Angus Scott-
  728. *--                           Fleming)
  729. *-- Calls       : None
  730. *-- Called by...: Any
  731. *-- Usage.......: ? StripWord(<cString>,[<cSeparator>])
  732. *-- Examples....: Lastname = StripWord( "Carrie Nation" )
  733. *--                         (returns "Nation")
  734. *--               InputData = StripWord( "RICHARD;HUGHES;AR;AN",";" )
  735. *--                         (returns HUGHES;AR;AN" )
  736. *-- Returns.....: string trimmed of trailing spaces, and trimmed on the
  737. *--               left to remove leading spaces, with the first "word"
  738. *--               removed. A "word" is defined as all characters up to
  739. *--               the first space, or up to the first occurrence of the
  740. *--               specified separator character.
  741. *-- Parameters..: cString    - character string to be stripped.
  742. *--               cSeparator - optional separating character (default 
  743. *--                              is " ")
  744. *----------------------------------------------------------------------
  745.  
  746.    parameters string, separator
  747.  
  748.    if .not.(type("separator") = "C" .and. len(m->separator)=1)
  749.       separator = " "
  750.    endif
  751.    private cW
  752.    m->cW = trim( ltrim( m->string ) )
  753.  
  754. RETURN iif( m->separator $ m->cW, ;
  755.           ltrim(substr(m->cW, at( m->separator, m->cW ) + 1)), m->cW )
  756. *-- EoF: StripWord()
  757.  
  758. FUNCTION Plural
  759. *----------------------------------------------------------------------
  760. *-- Programmer..: Kelvin Smith (KELVIN)
  761. *-- Date........: 08/27/1992
  762. *-- Notes.......: Returns number in string form, and pluralized form of
  763. *--               noun, including converting "y" to "ies", unless the
  764. *--               "y" is preceded by a vowel.  Works with either upper
  765. *--               or lower case nouns (based on last character).
  766. *--             : As no doubt all are aware, English includes many
  767. *--               irregular plural forms; to trap for all is not worth-
  768. *--               while (how often do you really need to print out die/
  769. *--               dice?). This should handle the vast majority of needs
  770. *-- Written for.: dBASE IV, 1.5
  771. *-- Rev. History: 08/27/1992 1.0 - Original version
  772. *-- Calls.......: None
  773. *-- Called by...: Any
  774. *-- Usage.......: Plural(<nCnt>, <cNoun>)
  775. *-- Examples....: Plural(1, "flag")    returns "1 flag"
  776. *--               Plural(0, "store")   returns "0 stores"
  777. *--               Plural(5, "COMPANY") returns "5 COMPANIES"
  778. *-- Returns.....: String with number and noun, no trailing spaces
  779. *-- Parameters..: nCnt  = Count value for noun (how many of cNoun?)
  780. *--               cNoun = Noun to pluralize
  781. *----------------------------------------------------------------------
  782.  
  783.    parameters nCnt, cNoun
  784.    private cNounOut, cLast, c2Last, cLast2, lUpper
  785.  
  786.    if nCnt = 1
  787.       m->cNounOut = trim(m->cNoun)
  788.    else
  789.       m->cNounOut = trim(m->cNoun)          && No trailing spaces
  790.       cLast = right(m->cNounOut, 1)
  791.       lUpper = isupper(m->cLast)         && Upper case?
  792.       cLast = upper(m->cLast)
  793.       c2Last = upper(substr(m->cNounOut, len(m->cNounOut) - 1, 1))
  794.       cLast2 = m->c2Last + m->cLast
  795.  
  796.       * If the noun ends in "Y", normally we change "Y" to "IES".
  797.       * However, if the "Y" is preceded by a vowel, just add "S".
  798.       if m->cLast = "Y" .and. at(m->c2Last, "AEIOU") = 0
  799.          cNounOut = left(m->cNounOut, len(m->cNounOut) - 1) +;
  800.                     iif(m->lUpper, "IES", "ies")
  801.       else
  802.          if m->cLast = "S" .or. m->cLast = "X" ;
  803.                         .or. m->cLast2 = "CH" .or. m->cLast2 = "SH"
  804.             cNounOut = m->cNounOut + iif(m->lUpper, "ES", "es")
  805.          else
  806.             cNounOut = m->cNounOut + iif(m->lUpper, "S", "s")
  807.          endif
  808.       endif
  809.    endif
  810.  
  811. RETURN ltrim(str(m->nCnt)) + " " + m->cNounOut
  812. *-- EoF: Plural()
  813.  
  814. FUNCTION StrComp
  815. *----------------------------------------------------------------------
  816. *-- Programmer..: Sri Raju (Borland Technical Support)
  817. *-- Date........: 08/01/1992
  818. *-- Notes.......: From Technotes, August, 1992, "Strings and Things"
  819. *--               This function compares the contents of two strings.
  820. *--               If cStr1 is less than cStr2, return -1
  821. *--               If cStr1 is equal to  cStr2, return 0
  822. *--               If cStr1 is greater than cStr2, return 1
  823. *-- Written for.: dBASE IV, 1.5
  824. *-- Rev. History: 08/01/1992 -- Original Release
  825. *-- Calls.......: None
  826. *-- Called by...: Any
  827. *-- Usage.......: StrComp(<cStr1>,<cStr2>)
  828. *-- Example.....: ? StrComp("TEST","TEXT")
  829. *-- Returns.....: Numeric (see notes)
  830. *-- Parameters..: cStr1 = First string
  831. *--               cStr2 = Second string
  832. *----------------------------------------------------------------------
  833.   
  834.    parameters cStr1,cStr2
  835.  
  836.    cExact = set("EXACT")
  837.    set exact on
  838.  
  839.    do case
  840.       case m->cStr1 = m->cStr2
  841.          nReturn = 0
  842.       case m->cStr1 > m->cStr2
  843.          nReturn = 1
  844.       case m->cStr1 < m->cStr2
  845.          nReturn = -1
  846.    endcase
  847.  
  848.    set exact &cExact.
  849.  
  850. RETURN m->nReturn
  851. *-- EoF: StrComp()
  852.  
  853. FUNCTION StrOccur
  854. *----------------------------------------------------------------------
  855. *-- Programmer..: Sri Raju (Borland Technical Support)
  856. *-- Date........: 08/01/1992
  857. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  858. *--               Calculates the number of occurences of a string in
  859. *--               another given character or memo field.
  860. *-- Written for.: dBASE IV, 1.5
  861. *-- Rev. History: 08/01/1992 -- Original Release
  862. *-- Calls.......: NumOccur()           Function in STRINGS.PRG
  863. *-- Called by...: Any
  864. *-- Usage.......: StrOccur(<cInString>,<cFindString>)
  865. *-- Example.....: ? StrOccur("NOTES","every")
  866. *--                 find all occurences of "every" in Memo: NOTES.
  867. *-- Returns.....: Numeric
  868. *-- Parameters..: cInString   = "Large" string -- to be looked "in". If
  869. *--                             a Memo, name of memo field must be in
  870. *--                             quotes or passed as a memvar and record
  871. *--                             pointer must be on correct record.
  872. *--               cFindString = "Small" string -- to be found in larger
  873. *--                             string.
  874. *----------------------------------------------------------------------
  875.  
  876.    parameters cInString, cFindString
  877.  
  878.    nBytes = 0
  879.    lMemo = .f.
  880.    nReturn = 0
  881.  
  882.    if pCount() # 2
  883.       * not enough parameters or too many parameters passed ...
  884.       ?"ERROR. Usage: StrOccur(<string>|<memo fld name>,<string>)"
  885.       RETURN (0)
  886.    endif
  887.    if type("CINSTRING") = "M"
  888.       lMemo = .t.
  889.    else
  890.       RETURN (NumOccur(m->cInstring,m->cFindString))
  891.    endif
  892.  
  893.    *-- process a memo ...
  894.    if m->lMemo
  895.       nTotLen = len(&cInString.)
  896.       n = 1
  897.       nOffSet = 0
  898.       cTempStr = " "
  899.       do while m->nOffSet <= m->nTotLen
  900.          cTempStr = "arr"+ltrim(str(m->n))  && ?
  901.          if (m->nOffSet + 254) > m->nTotLen
  902.             cTempStr = substr(&cInString.,m->nOffSet+1,m->nOffSet+254)
  903.          else
  904.             cTempStr = substr(&cInString.,m->nOffSet+1,m->nTotLen)
  905.          endif
  906.          nReturn = m->nReturn + NumOccur(m->cTempStr,m->cFindStr)
  907.          n = m->n + 1
  908.          nOffSet = m->nOffSet + 254
  909.       enddo
  910.    endif
  911.  
  912. RETURN (m->nReturn)
  913. *-- EoF: StrOccur()
  914.  
  915. FUNCTION NumOccur
  916. *----------------------------------------------------------------------
  917. *-- Programmer..: Sri Raju (Borland Technical Support)
  918. *-- Date........: 08/01/1992
  919. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  920. *--               Calculates the number of occurences of a string in
  921. *--               another string.
  922. *-- Written for.: dBASE IV, 1.5
  923. *-- Rev. History: 08/01/1992 -- Original Release
  924. *-- Calls.......: None
  925. *-- Called by...: StrOccur()           Function in STRINGS.PRG
  926. *-- Usage.......: NumOccur(<cInString>,<cFindString>)
  927. *-- Example.....: ? NumOccur("This is a string","is")
  928. *-- Returns.....: Numeric (integer -- # of times string occurs)
  929. *-- Parameters..: cInString   = "Large" string -- to be looked 'in'
  930. *--               cFindString = "Small" string -- to be looked for
  931. *----------------------------------------------------------------------
  932.  
  933.    parameters cInString, cFindString
  934.  
  935.    cHoldStr = " "
  936.    nReturn = 0
  937.    cInit = m->cInString
  938.  
  939.    do while len(m->cInit) => 1
  940.       cHoldStr = m->cInit
  941.       if at(m->cFindString,m->cHoldStr) > 0
  942.          nReturn = m->nReturn + 1
  943.          cInit = substr( m->cHoldStr, ;
  944.                  at(m->cFindString,m->cHoldStr) + len(m->cFindString) )
  945.       else
  946.          cInit = ""
  947.       endif
  948.    enddo
  949.  
  950. RETURN (m->nReturn)
  951. *-- EoF: NumOccur()
  952.  
  953. FUNCTION ReplMemo
  954. *----------------------------------------------------------------------
  955. *-- Programmer..: Sri Raju (Borland Technical Support)
  956. *-- Date........: 08/01/1992
  957. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  958. *--               Globally searches and replaces a string with another
  959. *--               string in a character field/memvar or memo field.
  960. *-- Written for.: dBASE IV, 1.5
  961. *-- Rev. History: 08/01/1992 -- Original Release
  962. *-- Calls.......: MemStuff()           Function in STRINGS.PRG
  963. *-- Called by...: Any
  964. *-- Usage.......: ReplMemo("cSource",<cCurrStr>,<cNewStr>)
  965. *-- Example.....: ?ReplMemo("NOTES","Test","testing")
  966. *-- Returns.....: .T. if a memo field, or character string with changes
  967. *-- Parameters..: cSource  = Source to make changes IN
  968. *--               cCurrStr = Current string (item(s)) to be changed
  969. *--               cNewStr  = Change 'Current' to this ....
  970. *----------------------------------------------------------------------
  971.  
  972.    parameters cSource, cCurrStr, cNewStr
  973.  
  974.    cConsole = set("CONSOLE")
  975.  
  976.    nBytes = 0
  977.    nPointer = 0
  978.    nMaster = 0
  979.  
  980.    *-- error
  981.    if pcount() # 3   && valid number of parms
  982.       ?"Error."
  983.       ?"Usage: ReplMemo(<Memo/string>,<Current String>,<New String>)"
  984.       RETURN .f.
  985.    endif
  986.  
  987.    *-- start
  988.    if type(m->cSource) = "M"                     && if a memo ...
  989.       if len(&cSource.) > 254                    && if > 254 char
  990.          cNewFile = (m->cSource)+".TXT"          && create a temp file
  991.          erase m->cNewFile
  992.          nPointer = fcreate(m->cNewFile,"A")
  993.       endif
  994.    else
  995.       *-- if not a memo, just perform the replace ...
  996.       RETURN (MemStuff(m->cSource,m->cCurrStr,m->cNewStr))
  997.    endif
  998.  
  999.    *-- memo handling ...
  1000.    nTotLen = len(&cSource.)
  1001.    nCounter = 1
  1002.    nOffSet = 0
  1003.    do while m->nOffSet <= m->nTotLen
  1004.       cTempStr = "arr"+ltrim(str(m->nCounter))
  1005.       if (m->nOffSet+200) < m->nTotLen
  1006.          cTempStr = substr(&cSource.,m->nOffSet+1,200)
  1007.       else
  1008.          cTempStr = substr(&cSource.,m->nOffSet+1,m->nTotLen)
  1009.       endif
  1010.       cTemp2 = space(200)
  1011.       cTemp2 = MemStuff(m->cTempStr, m->cCurrStr, m->cNewStr)
  1012.       nBytes = fwrite(m->nPointer,m->cTemp2)
  1013.  
  1014.       nCounter = m->nCounter + 1
  1015.       nOffSet = m->nOffSet + 200
  1016.    enddo
  1017.  
  1018.    nNull = fclose(m->nPointer)
  1019.    append memo &cSource. from (m->newfile) overwrite
  1020.  
  1021. RETURN .T.
  1022. *-- EoF: ReplMemo()
  1023.  
  1024. FUNCTION MemStuff
  1025. *----------------------------------------------------------------------
  1026. *-- Programmer..: Sri Raju (Borland Technical Support)
  1027. *-- Date........: 08/01/1992
  1028. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  1029. *--               Replaces a specific string in a character string, by
  1030. *--               another, and returns the resultant string.
  1031. *-- Written for.: dBASE IV, 1.5
  1032. *-- Rev. History: 08/01/1992 -- Original Release
  1033. *-- Calls.......: Stub()               Function in STRINGS.PRG
  1034. *-- Called by...: ReplMemo()           Funciton in STRINGS.PRG
  1035. *-- Usage.......: MemStuff(<cSource>,<cCurrStr>,<cNewStr>)
  1036. *-- Example.....: ? MemStuff(cTestStr,"Test","Testing")
  1037. *-- Returns.....: Character
  1038. *-- Parameters..: cSource  = Source to make changes IN
  1039. *--               cCurrStr = Current string (item(s)) to be changed
  1040. *--               cNewStr  = Change 'Current' to this ....
  1041. *----------------------------------------------------------------------
  1042.  
  1043.    parameters cSource, cCurrStr, cNewStr
  1044.    private cSource, cCurrStr, cNewStr
  1045.  
  1046.    cRetStr  = ""
  1047.    cHoldStr = ""
  1048.    cInitStr = m->cSource
  1049.  
  1050.    do while len(m->cInitStr) => 1
  1051.       cHoldStr = m->cInitStr
  1052.       if at(m->cCurrStr,m->cNewStr) > 0
  1053.          cTemp = substr(m->cInitStr,1,at(m->cCurrStr,m->cHoldStr))
  1054.          nPos  = at(m->cCurrStr,m->cHoldStr)
  1055.          cReturn = m->cReturn+Stub(m->cTemp,m->nPos,m->cNewStr)
  1056.          cInitStr = substr( m->cHoldStr, ;
  1057.                     at( m->cReplace, m->cHoldStr ) + len(m->cNewStr) )
  1058.       else
  1059.          cReturn = trim(m->cInitStr)+trim(m->cHoldStr)
  1060.          cInitStr = ""
  1061.       endif
  1062.    enddo
  1063.  
  1064. RETURN (m->cReturn)
  1065. *-- EoF: MemStuff()
  1066.  
  1067. FUNCTION Stub
  1068. *----------------------------------------------------------------------
  1069. *-- Programmer..: Sri Raju (Borland Technical Support)
  1070. *-- Date........: 08/01/1992
  1071. *-- Notes.......: This returns a specific number of characters from the
  1072. *--               given string specified by the parameter innum, added
  1073. *--               to the third parameter.
  1074. *-- Written for.: dBASE IV, 1.5
  1075. *-- Rev. History: 08/01/1992 -- Original Release
  1076. *-- Calls.......: None
  1077. *-- Called by...: MemStuff()           Function in STRINGS.PRG
  1078. *-- Usage.......: Stub(<cString>,nIn,<cIn>)
  1079. *-- Example.....: ? Stub(cTest,5,"Test")
  1080. *-- Returns.....: Character
  1081. *-- Parameters..: cString = Character string to look in
  1082. *--               nIn     = # of characters to return
  1083. *--               cIn     = characters to add to the end of ...
  1084. *----------------------------------------------------------------------
  1085.  
  1086.    parameters cString, nIn, cIn
  1087.  
  1088. RETURN trim(substr(m->cString,1,m->nIn-1)+m->cIn)
  1089. *-- EoF: Stub()
  1090.  
  1091. FUNCTION FirstMem
  1092. *----------------------------------------------------------------------
  1093. *-- Programmer..: Sri Raju (Borland Technical Support)
  1094. *-- Date........: 08/01/1992
  1095. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  1096. *--               Capitalizes the first character of all the words in
  1097. *--               the string that is passed as a parameter, and returns
  1098. *--               the resultant string. If a name of a memo field is
  1099. *--               pass as the parameter, it re-writes the memo field,
  1100. *--               and returns a .T.
  1101. *-- Written for.: dBASE IV, 1.5
  1102. *-- Rev. History: 08/01/1992 -- Original Release
  1103. *-- Calls.......: FirstCap()           Function in STRINGS.PRG
  1104. *-- Called by...: None
  1105. *-- Usage.......: FirstMem(cInStr)
  1106. *-- Example.....: ? FirstMem("this is a string")
  1107. *-- Returns.....: Either character string with first letter of each
  1108. *--               word capitalized, or .T. (if a Memo).
  1109. *-- Parameters..: cInStr = character string or Memo Field name
  1110. *----------------------------------------------------------------------
  1111.   
  1112.    parameters cInStr
  1113.  
  1114.    nBytes = 0
  1115.    lMemo = .F.
  1116.    lReturn = .T.
  1117.    nFPtr = 0
  1118.    nMasterCnt = 0
  1119.  
  1120.    if pcount() # 1
  1121.       ? "Error."
  1122.       ? "Usage:- FIRSTMEM (<string>) "
  1123.       lMemo = .F.
  1124.    else
  1125.       if type(instr) = "M"
  1126.          lMemo = .T.
  1127.          cNewFile = (m->cInStr) + ".txt"
  1128.          erase (m->cnewfile)
  1129.          nFPtr = fcreate(m->cNewFile, "A")
  1130.       else
  1131.          lReturn = .F.
  1132.       endif
  1133.    endif
  1134.  
  1135.    if lMemo
  1136.       nTotLen = len(&CInStr.)
  1137.       nCntr = 1
  1138.       nOffSet = 0
  1139.       do while m->nOffSet <= m->nTotLen
  1140.          if (m->nOffSet + 250) < m->nTotLen
  1141.             cTemp = substr(&cInStr., m->nOffSet + 1, 250)
  1142.          else
  1143.             cTemp = substr(&CInStr., m->nOffSet + 1, m->nTotLen)
  1144.          endif
  1145.          cTempStr = space(250)
  1146.          cTempStr = FirstCap(m->cTemp)
  1147.          nBytes = fwrite(m->nFPtr, m->cTempStr)
  1148.  
  1149.          nCntr = m->nCntr + 1
  1150.          nOffSet = m->nOffSet + 250
  1151.       enddo
  1152.       x = fclose(m->nFPtr)
  1153.       append memo &cInStr. from (m->CNewFile) overwrite
  1154.    endif
  1155.  
  1156.    if lMemo .or. lReturn
  1157.       RETURN (.F.)
  1158.    else
  1159.       RETURN (FirstCap(m->cInStr))
  1160.    endif
  1161. *-- EoF: FirstMem()
  1162.  
  1163. FUNCTION FirstCap
  1164. *----------------------------------------------------------------------
  1165. *-- Programmer..: Sri Raju (Borland Technical Support)
  1166. *-- Date........: 08/01/1992
  1167. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  1168. *--               Capitalizes the first character of a string.
  1169. *-- Written for.: dBASE IV, 1.5
  1170. *-- Rev. History: 08/01/1992 -- Original Release
  1171. *-- Calls.......: None
  1172. *-- Called by...: FirstMem()           Function in STRINGS.PRG
  1173. *-- Usage.......: FirstCap(<cInString>) 
  1174. *-- Example.....: ?FirstCap("stringofcharacters")
  1175. *-- Returns.....: String with first character captilized.
  1176. *-- Parameters..: cInString = String to cap the first letter of
  1177. *----------------------------------------------------------------------
  1178.  
  1179.    parameters cInString
  1180.    cRetString = ""
  1181.    cIStr = m->cInString
  1182.  
  1183.    do while len(m->cIStr) > 1
  1184.       nPos = at(" ", m->cIStr)
  1185.       if nPos <> 0
  1186.          cRetString = m->cRetString + upper(left(m->cIStr, 1)) + ;
  1187.             substr(m->cIStr, 2, m->nPos-1)
  1188.       else
  1189.          cRetString = m->cRetString + upper(left(m->cIStr, 1)) + ;
  1190.             substr(m->cIStr, 2)
  1191.          exit
  1192.       endif
  1193.       do while substr(m->cIStr, m->nPos, 1) = " "
  1194.          nPos = m->nPos + 1
  1195.       enddo
  1196.       cIStr = substr(m->cIStr, m->nPos)
  1197.    enddo
  1198.  
  1199. RETURN (m->cRetString)
  1200. *-- EoF: FirstCap()
  1201.  
  1202. FUNCTION StripND
  1203. *----------------------------------------------------------------------
  1204. *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
  1205. *-- Date........: 01/04/1993
  1206. *-- Notes.......: Strips characters out of a numeric character string
  1207. *--               (like perhaps, a date: 01/04/93 would become 010493)
  1208. *-- Written for.: dBASE IV, 1.5
  1209. *-- Rev. History: 01/04/1993 -- Original Release
  1210. *-- Calls.......: IsDigit()            Function in STRINGS.PRG
  1211. *-- Called by...: Any
  1212. *-- Usage.......: StripND(<cNumArg>)
  1213. *-- Example.....: keyboard stripnd(dtoc(date()))
  1214. *-- Returns.....: character string
  1215. *-- Parameters..: cNumArg = Character memvar containing a "numeric"
  1216. *--                         string
  1217. *----------------------------------------------------------------------
  1218.  
  1219.    parameters cNumArg
  1220.    private cNumStr, nLen, cRetVal, nCount, cChar
  1221.  
  1222.    cNumStr = m->cNumArg
  1223.    nLen = len(m->cNumStr)
  1224.    cRetVal = ""
  1225.    nCount = 0
  1226.    do while m->nCount <= m->nLen
  1227.       nCount = m->nCount + 1
  1228.       cChar = substr(m->cNumStr,m->nCount,1)
  1229.       if isdigit(m->cChar)
  1230.          cRetVal = m->cRetVal+m->cChar
  1231.       endif
  1232.    enddo
  1233.  
  1234. RETURN m->cRetVal
  1235. *-- EoF: StripND()
  1236.  
  1237. FUNCTION Strip
  1238. *----------------------------------------------------------------------
  1239. *-- Programmer..: Kenneth Chan [ZAK] (CIS: 72662,1305)
  1240. *-- Date........: 01/05/1993
  1241. *-- Notes.......: Strips out specified character(s) from a string
  1242. *-- Written for.: dBASE IV, 1.5
  1243. *-- Rev. History: 01/05/1993 -- Original Release
  1244. *-- Calls.......: None
  1245. *-- Called by...: Any
  1246. *-- Usage.......: Strip(<cVar>,<cArg>)
  1247. *-- Example.....: ?strip(dtoc(date(),"/")
  1248. *-- Returns.....: Character
  1249. *-- Parameters..: cVar = variable/field to remove character(s) from
  1250. *--               cArg = item to remove from cVar
  1251. *----------------------------------------------------------------------
  1252.  
  1253.   parameter cVar, cArg
  1254.   do while m->cArg $ m->cVar
  1255.     cVar = stuff( m->cVar, at( m->cArg, m->cVar ), 1, "" )
  1256.   enddo
  1257.  
  1258. RETURN m->cVar
  1259. *-- EoF: Strip()
  1260.  
  1261. PROCEDURE WordWrap
  1262. *----------------------------------------------------------------------
  1263. *-- Programmer..: David Frankenbach (CIS: 72147,2635)
  1264. *-- Date........: 01/14/1993 (Version 1.1)
  1265. *-- Notes.......: Wraps a long string, breaking it into strings that
  1266. *--               have a maximum length of nWidth. The first output is
  1267. *--                displayed@nRow, nCol. Words are not split ...
  1268. *-- Written for.: dBASE IV, 1.5
  1269. *-- Rev. History: 01/06/1993 -- Original Release (Version 1.0)
  1270. *--               01/14/1993 -- Version 1.1 -- Corrected side-effect of 
  1271. *--                       destroying string arg, added test for 
  1272. *--                       string[nWidth+1] = " "
  1273. *-- Calls.......: None
  1274. *-- Called by...: Any
  1275. *-- Usage.......: do WordWrap with <nRow>, <nCol>, <cString>, <nWidth>
  1276. *-- Example.....: do WordWrap with 2,2,cText,38
  1277. *-- Returns.....: None
  1278. *-- Parameters..: nRow     = Row to display first line at
  1279. *--               nCol     = Left side of area to display text at
  1280. *--               cString  = text to wrap
  1281. *--               nWidth   = Width of area to wrap text in
  1282. *----------------------------------------------------------------------
  1283.  
  1284.    parameters nRow, nCol, cString, nWidth
  1285.    private cTemp, nI, cStr
  1286.  
  1287.    cStr = m->cString            && work with a COPY of input, to
  1288.                                 && avoid destroying original
  1289.  
  1290.    do while len(m->cStr) > 0    && while there's something to work on
  1291.       if (m->nWidth < len(m->cStr))
  1292.          nI = m->nWidth         && look for last " " in first nWidth
  1293.  
  1294.          if substr(m->cStr, m->nI + 1, 1) # " "
  1295.             do while ( (m->nI > 0) .and. ;
  1296.                        (substr(m->cStr,m->nI,1) # " ") )
  1297.                nI = m->nI - 1
  1298.             enddo
  1299.          endif
  1300.  
  1301.          if nI = 0              && no spaces
  1302.             nI = m->nWidth      && get first nWidth characters
  1303.          endif
  1304.       else
  1305.          nI = len(m->cStr)      && use the rest of the string
  1306.       endif
  1307.  
  1308.       cTemp = left(m->cStr,m->nI)  && get the part to display
  1309.  
  1310.       if m->nI < len(m->cStr)   && remove that part
  1311.          cStr = ltrim(substr(m->cStr,m->nI + 1))
  1312.       else
  1313.          cStr = ""
  1314.       endif
  1315.  
  1316.       *-- display it
  1317.       @nRow,nCol say m->cTemp
  1318.       *-- move to next row
  1319.       nRow = m->nRow + 1
  1320.  
  1321.    enddo
  1322.  
  1323. RETURN
  1324. *-- EoP: WordWrap
  1325.  
  1326. FUNCTION BreakName
  1327. *----------------------------------------------------------------------
  1328. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  1329. *-- Date........: 03/21/1993
  1330. *-- Notes.......: Returns part of a name based on user positioning of
  1331. *--               cursor. This function requires the programmer to set
  1332. *--               up any window desired; the writing surface must have
  1333. *--               a minimum width of 45 characters or the length of the
  1334. *--               name plus 2, whichever is greater, and must be at
  1335. *--               least 4 rows high.
  1336. *-- Written for.: dBASE IV 1.5 ( earlier versions will require changing
  1337. *--               the optional parameter to a required one )
  1338. *-- Rev. History: 03/21/1993 -- Original
  1339. *-- Calls.......: NamePart()                    function in STRINGS.PRG
  1340. *--               MarkLine()                    function in STRINGS.PRG
  1341. *-- Called by...: Any
  1342. *-- Usage.......: Breakname("<cName>" [,"<cPart>"] )
  1343. *-- Example.....: LastName = BreakName( "Dr. E. N. Smedley III, "L" )
  1344. *-- Returns.....: character     = substring containing part of the name
  1345. *-- Parameters..: cName         = Name to parse
  1346. *--               cPart         = optional, character from set below:
  1347. *--                                 P -- prefix( es )
  1348. *--                                 F -- first name
  1349. *--                                 M -- middle name or initial
  1350. *--                                 L -- last name
  1351. *--                                 S -- suffix( es )
  1352. *----------------------------------------------------------------------
  1353.  
  1354.    parameters cName, cPart
  1355.    private nPos, cP, cParts, nPart, cPrompts, nFirst, nLast, cRet
  1356.    private nRow, nCol, nOff
  1357.  
  1358.    cRet = ""
  1359.    store 0 to nPos, nParts, nPart
  1360.    cParts = "PFMLS"
  1361.    *                    1         2         3         4
  1362.    * Ruler-->  123456789012345678901234567890123456789012
  1363.    cPrompts = "desired part  prefix(es)    first name    " ;
  1364.             + "middle name(s)last name     suffix(es)"
  1365.    if type( "cPart" ) # "C" .or. "" = m->cPart
  1366.       nPos = 1
  1367.       cP = "?"
  1368.    endif
  1369.    if m->nPos = 0
  1370.       cP = upper( left( ltrim( m->cPart ), 1 ) )
  1371.       nPart = at( m->cP, m->cParts )
  1372.    endif
  1373.    if m->nPart = 0
  1374.       nPos = 1
  1375.    else
  1376.       nPos = NameMark( m->cName, m->cP, "B" )
  1377.       nPos = iif( m->nPos = 0, len( m->cName ) + 1, m->nPos )
  1378.    endif
  1379.    nRow = row()
  1380.    nCol = col()
  1381.    nOff = int( ( 43 - len( m->cName ) ) / 2 )
  1382.    @ m->nRow, m->nCol + m->nOff clear to ;
  1383.        m->nRow + 4, m->nCol + max( 45, 45 - m->nOff )
  1384.    @ m->nRow, m->nCol say ;
  1385.        "Please use the arrow keys to place the cursor"
  1386.    @ m->nRow + 1, m->nCol say "on the FIRST character of the "
  1387.    @ m->nRow + 1, col() say ;
  1388.        trim( substr( m->cPrompts, m->nPart * 14 + 1, 14 ) ) + ":"
  1389.    @ m->nRow + 4, m->nCol + m->nOff say ""
  1390.    nFirst = MarkLine( m->cName, m->nPos )
  1391.    if m->nFirst = 0 .or. m->nFirst > len( m->cName )
  1392.       RETURN m->cRet
  1393.    endif
  1394.    if m->cP = "S"
  1395.       nLast = len( trim( m->cName ) )
  1396.    else
  1397.       @ m->nRow, m->nCol + m->nOff clear to ;
  1398.         m->nRow + 4, m->nCol + max( 43, 43 - m->nOff )
  1399.       @ m->nRow, m->nCol say ;
  1400.         "Please use the arrow keys to place the cursor"
  1401.       @ m->nRow + 1, m->nCol say " on the LAST character of the "
  1402.       @ m->nRow + 1, col() say ;
  1403.         trim( substr( m->cPrompts, m->nPart * 14 + 1, 14 ) ) + ":"
  1404.       nPos = NameMark( m->cName, m->cP, "E" )
  1405.       @ m->nRow + 4, m->nCol + m->nOff say ""
  1406.       nLast = MarkLine( m->cName, m->nPos )
  1407.    endif
  1408.    if m->nLast > m->nFirst
  1409.       cRet = substr(m->cName, m->nFirst, m->nLast - m->nFirst + 1)
  1410.    endif
  1411.  
  1412. RETURN m->cRet
  1413. *-- EoF: BreakName()
  1414.  
  1415. FUNCTION NamePart
  1416. *----------------------------------------------------------------------
  1417. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  1418. *-- Date........: 03/21/1993
  1419. *-- Notes.......: Guesses which portion of a name held in a single
  1420. *--               variable in the usual printing order corresponds to
  1421. *--               the letter code given for prefix, first name, middle
  1422. *--               names, last name, or suffixes and returns that
  1423. *--               portion. This does not work correctly for all names
  1424. *--               and is recommended to be used only with some human
  1425. *--               interpretation of the results.
  1426. *-- Written for.: dBASE IV 1.5
  1427. *-- Rev. History: 03/21/1993 -- Original
  1428. *-- Calls.......: NameMark()                  function in STRINGS.PRG
  1429. *-- Called by...: Any
  1430. *-- Usage.......: NamePart( <cName> ,<cPart> )
  1431. *-- Example.....: Suffix = NamePart( "John Doe Jr. Ph. D.", "S" )
  1432. *-- Returns.....: character     = substring, part of the name, or null
  1433. *--                               string
  1434. *-- Parameters..: cName         = Name to parse
  1435. *--               cPart         = a character from the set below:
  1436. *--                                 P -- prefix
  1437. *--                                 F -- first name
  1438. *--                                 M -- middle name(s) or initial(s)
  1439. *--                                      or both
  1440. *--                                 L -- last name
  1441. *--                                 S -- suffix(es)
  1442. *----------------------------------------------------------------------
  1443.  
  1444.    parameters cName, cPart
  1445.    private nStart, nStop, cP, nTrimmed, nMark, cN1, cN2
  1446.  
  1447.    store 0 to nStart, nStop
  1448.    cRet = ""
  1449.    if type( "cPart" ) # "C" .or. "" = m->cPart .or. "" = m->cName
  1450.       RETURN m->cRet
  1451.    endif
  1452.    cP = upper( left( m->cPart, 1 ) )
  1453.    if .not. m->cP $ "PFMLS"
  1454.       RETURN m->cRet
  1455.    endif
  1456.    nStart = NameMark( m->cName, m->cP, "B" )
  1457.    nStop  = NameMark( m->cName, m->cP, "E" )
  1458.    if m->nStop > m->nStart .and. m->nStart > 0
  1459.       cRet = substr(m->cName, m->nStart, m->nStop - m->nStart + 1)
  1460.    endif
  1461.  
  1462. RETURN m->cRet
  1463. *-- EoF: NamePart()
  1464.  
  1465. FUNCTION NameMark
  1466. *----------------------------------------------------------------------
  1467. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  1468. *-- Date........: 03/21/1993
  1469. *-- Notes.......: Guesses which portion of a name held in a single
  1470. *--               variable in the usual printing order corresponds to
  1471. *--               the letter code given for prefix, first name, middle
  1472. *--               names, last name or suffixes and returns the position
  1473. *--               of the character that begins or ends that portion.
  1474. *--               This does not work properly for all names and is
  1475. *--               recommended to be used with MarkLine(), as in
  1476. *--               BreakName().
  1477. *-- Written for.: dBASE IV 1.5
  1478. *-- Rev. History: 03/21/1993 -- Original
  1479. *-- Calls.......: Rat()                         function in STRINGS.PRG 
  1480. *-- Called by...: Any
  1481. *-- Usage.......: NameMark( <cName> ,<cPart>, <cEnd> )
  1482. *-- Example.....: Suffix = NamePart( "John Doe Jr. Ph. D.", "S", "B" )
  1483. *-- Returns.....: numeric       = position in cName of requested
  1484. *--                               character, or 0, or null string
  1485. *-- Parameters..: cName         = Name to parse
  1486. *--               cPart         = a character from the set below:
  1487. *--                                 P -- prefix
  1488. *--                                 F -- first name
  1489. *--                                 M -- middle name(s) or initial(s)
  1490. *--                                      or both
  1491. *--                                 L -- last name
  1492. *--                                 S -- suffix(es)
  1493. *--               cEnd          = a character from the set below:
  1494. *--                                 B or F -- first char of the part
  1495. *--                                 E or L -- last char of the part
  1496. *----------------------------------------------------------------------
  1497.  
  1498.    parameters cName, cPart, cEnd
  1499.    private nStart, nStop, nRet, cP, cE, nTrimmed, nM1, nM2, cN1, cN2,;
  1500.            lC
  1501.  
  1502.    * intialize and check for proper parameters
  1503.    store 0 to nStart, nStop, nRet
  1504.    if type( "cPart" ) + type( "cName" ) + type( "cEnd" ) # "CCC" ;
  1505.       .or. "" = m->cName .or. "" = m->cPart .or. "" = m->cEnd
  1506.      RETURN m->nRet
  1507.    endif
  1508.    cP = upper( left( m->cPart, 1 ) )
  1509.    if .not. m->cP $ "PFMLS"
  1510.       RETURN m->nRet
  1511.    endif
  1512.    cE = upper( left( m->cEnd, 1 ) )
  1513.    do case
  1514.       case m->cE $ "BF"
  1515.          cE = "B"
  1516.       case m->cE $ "EL"
  1517.          cE = "E"
  1518.       otherwise
  1519.          RETURN m->nRet
  1520.    endcase
  1521.    * remove end spaces but count leading ones
  1522.    cN1 = ltrim( m->cName )
  1523.    nTrimmed = len( m->cName ) - len( m->cN1 )
  1524.    cN1 = trim( m->cN1 )
  1525.    * find interior space; if none we're done
  1526.    nM1 = at( " ", m->cN1 )
  1527.    if m->nM1 = 0
  1528.       cRet = iif( m->cP = "L", m->cN1, "" )
  1529.       RETURN m->cRet
  1530.    endif
  1531.    * anything ending in a period but 1 initial is a prefix
  1532.    if m->nM1 > 3 .and. substr( m->cN1, m->nM1 - 1, 1 ) = "."
  1533.       if m->cP = "P"
  1534.          nStart = 1
  1535.          nStop = m->nM1 - 1
  1536.       else
  1537.          cN2 = ltrim( substr( m->cN1, m->nM1 + 1 ) )
  1538.          nTrimmed = m->nTrimmed + len( m->cN1 ) - len( m->cN2 )
  1539.          cN1 = m->cN2
  1540.          nM1 = at( " ", m->cN1 )
  1541.       endif
  1542.    else
  1543.       if m->cP = "P"
  1544.          nStart = 1
  1545.       endif
  1546.    endif
  1547.    * if we're not looking for prefix, first word is first name
  1548.    * if not looking for it either, trim it off and adjust space count
  1549.    if m->nStart = 0
  1550.       if m->cP = "F"
  1551.          nStart = 1
  1552.          nStop = m->nM1 - 1
  1553.       else
  1554.          cN2 = ltrim( substr( m->cN1, m->nM1 + 1 ) )
  1555.          nTrimmed = m->nTrimmed + len( m->cN1 ) - len( m->cN2 )
  1556.          cN1 = m->cN2
  1557.       endif
  1558.    endif
  1559.    * if not done yet, look for suffix.  Anything after a comma plus
  1560.    * anything ending with period and certain common differentiators
  1561.    if m->nStart = 0
  1562.       nM1 = at( ",", m->cN1 )
  1563.       if m->nM1 > 0
  1564.          cN1 = left( m->cN1, m->nM1 - 1 )
  1565.          nM2 = m->nM1
  1566.       else
  1567.          nM2 = len( m->cN1 ) + 1
  1568.       endif
  1569.       nM1 = rat( " ", m->cN1 )
  1570.       lC = .T.
  1571.       do while m->lC
  1572.          lC = .F.
  1573.          if upper( right( m->cN1, 3 ) ) $ "III 2D 2ND 3D 3RD"
  1574.             nM1 = len( m->cN1 ) - ;
  1575.                 iif( left( right( m->cN1, 3 ), 1 ) = " ", 3, 4 )
  1576.             cN1 = left( m->cN1, m->nM1 )
  1577.             lC = .T.
  1578.             nM2 = m->nM1 + 2
  1579.             nM1 = rat( " ", m->cN1 )
  1580.          endif
  1581.          if m->nM1 > 0 .and. "." $ substr( m->cN1, m->nM1 )
  1582.             cN1 = left( m->cN1, m->nM1 - 1 )
  1583.             cL = .T.
  1584.             nM2 = m->nM1 + 1
  1585.             nM1 = rat( " ", m->cN1 )
  1586.          endif
  1587.       enddo
  1588.       * the two marks delineate the starts of the last name and suffix
  1589.       do case
  1590.          case m->cP = "S"
  1591.             nStart = m->nM2
  1592.             nStop = len( m->cName )
  1593.          case m->cP = "L"
  1594.             nStart = m->nM1 + 1
  1595.             nStop = m->nM2 - 1
  1596.          otherwise
  1597.             nStart = 1
  1598.             nStop = m->nM1 - 1
  1599.       endcase
  1600.    endif
  1601.    if m->nStart < m->nStop
  1602.       nStop = min( m->nStop, m->Nstart + len( trim( substr( m->cN1, ;
  1603.               m->Nstart, m->Nstop - m->Nstart + 1 ) ) ) - 1 )
  1604.       nRet = iif( m->cE = "B", m->nStart, m->nStop ) + m->nTrimmed
  1605.    endif
  1606.  
  1607. RETURN m->nRet
  1608. *-- EoF: NameMark()
  1609.  
  1610. FUNCTION MarkLine
  1611. *----------------------------------------------------------------------
  1612. *-- Programmer..: Jay Parsons (CIS: 72662,1302)
  1613. *-- Date........: 03/21/1993
  1614. *-- Notes.......: Presents a string with cursor at character given by
  1615. *--               numeric offset, allows user to move the cursor within
  1616. *--               the string using arrow keys and returns position
  1617. *--               within string at which cursor is located when edit
  1618. *--               is ended, or 0 if edit is ended by pressing {Esc}.
  1619. *--               The programmer must deal with opening windows,
  1620. *--               positioning the edit, etc. before calling the
  1621. *--               function. Mouse support not supplied.
  1622. *-- Written for.: dBASE IV 1.5
  1623. *-- Rev. History: 03/21/1993 -- Original
  1624. *-- Calls.......: None
  1625. *-- Called by...: Any
  1626. *-- Usage.......: MarkLine( <cLine> [, <nPos> ] )
  1627. *-- Example.....: ? MarkLine( "G. C. K. Chesterton", 10 )
  1628. *-- Returns.....: numeric, character position of the cursor,
  1629. *--                        0 if {Esc}
  1630. *-- Parameters..: cLine    = Line to parse
  1631. *--               nPos     = optional, default position of cursor
  1632. *--                          if omitted, cursor is at first character
  1633. *----------------------------------------------------------------------
  1634.  
  1635.    parameters cLine, nPos
  1636.    private nP, nRet, nCol, cCurs
  1637.  
  1638.    cCurs = set( "CURSOR" )
  1639.    set cursor on
  1640.    nP = iif( type( "nPos" ) = "L", 1, m->nPos )
  1641.    nRet = m->nP
  1642.    nCol = col()
  1643.    @ row(), m->nCol say m->cLine
  1644.    nKey = 0
  1645.    do while m->nKey # 27 .and. m->nKey # 13 .and. m->nKey # 23
  1646.       @ row(), m->nCol + m->nRet - 1 say ""
  1647.       nKey = inkey( 0 )
  1648.       do case
  1649.          case m->nKey = 27
  1650.             nRet = 0
  1651.          case m->nKey = 4 .and. m->nRet < len( m->cLine )
  1652.             nRet = m->nRet + 1
  1653.          case nKey = 19 .and. m->nRet > 1
  1654.             nRet = m->nRet - 1
  1655.       endcase
  1656.    enddo
  1657.    if cCurs = "OFF"
  1658.       set cursor off
  1659.    endif
  1660.  
  1661. RETURN m->nRet
  1662. *-- EoF: MarkLine() 
  1663.  
  1664. FUNCTION Decode
  1665. *----------------------------------------------------------------------
  1666. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
  1667. *-- Date........: 11/25/1992 (unknown.  Stolen from somewhere....)
  1668. *-- Note........: simple decoding for primitive password protection
  1669. *-- Written for.: dBASE IV 1.1+
  1670. *-- Rev. History: 11/25/1992 -- Original
  1671. *--               Mon  08-02-1993  tuning for performance
  1672. *-- Calls.......: None
  1673. *-- Called by...: Any
  1674. *-- Usage.......: Decode(<cInput>)
  1675. *-- Example.....: Password = Decode(cPassWd)
  1676. *-- Returns.....: decoded string
  1677. *-- Parameters..: <cInput> = encoded string
  1678. *----------------------------------------------------------------------
  1679.  
  1680.    parameters cInput
  1681.    private cString, n
  1682.  
  1683.    cString = m->cInput
  1684.    if isblank(m->cString)
  1685.       return m->cString
  1686.    else
  1687.       cpw = m->cString
  1688.       n = 1
  1689.       do while n <= len(trim(m->cString))
  1690.          cString = stuff( m->cInput, m->n, 1, ;
  1691.                  chr( asc( substr( m->cpw, m->n, 1 ) ) - m->n ) )
  1692.          n = m->n + 1
  1693.       enddo
  1694.    endif
  1695.  
  1696. RETURN m->cString
  1697. *-- EoF: Decode()
  1698.  
  1699. FUNCTION Encode
  1700. *----------------------------------------------------------------------
  1701. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
  1702. *-- Date........: 11/25/1992 (unknown.  Stolen from somewhere....)
  1703. *-- Note........: simple encoding for primitive password protection
  1704. *-- Written for.: dBASE IV 1.1+
  1705. *-- Rev. History: 11/25/1992 -- Original
  1706. *--               Mon  08-02-1993  tuning for performance
  1707. *-- Calls.......: None
  1708. *-- Called by...: Any
  1709. *-- Usage.......: Encode(<cInput>)
  1710. *-- Example.....: store encode(cPassWd) to PassWord
  1711. *-- Returns.....: encoded string
  1712. *-- Parameters..: cInput = unencoded string
  1713. *----------------------------------------------------------------------
  1714.  
  1715.    parameters cInput
  1716.    private cString, n
  1717.  
  1718.    cString = m->cInput
  1719.  
  1720.    * encode the password
  1721.    cpw = m->cString
  1722.    n = 1
  1723.    do while n <= len(trim(m->cString))
  1724.       cString = stuff( m->cString, m->n, 1,;
  1725.                chr( asc( substr( m->cpw, m->n, 1 ) ) + m->n ) )
  1726.       n = m->n + 1
  1727.    enddo
  1728.  
  1729. RETURN m->cString
  1730. *-- EoF: Encode()
  1731.  
  1732. FUNCTION ExEqual
  1733. *----------------------------------------------------------------------
  1734. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
  1735. *-- Date........: 11/26/1992  (Improvement on Genifer function)
  1736. *-- Note........: Test for two variables for exact match
  1737. *-- Written for.: dBASE IV 1.1+
  1738. *-- Rev. History: 11/26/1992 - test for TYPE MATCH as well!
  1739. *-- Calls.......: None
  1740. *-- Called by...: Any
  1741. *-- Usage.......: ExEqual(<cInput1>,<cInput2>)
  1742. *-- Example.....: if ExEqual(alias(),"XYZ")
  1743. *-- Returns.....: .T. (exact match), .F. (different types or no match)
  1744. *-- Parameters..: cInput1 = \
  1745. *--               cInput2 =  - two memvars to be compared
  1746. *----------------------------------------------------------------------
  1747.  
  1748.   parameters cInput1, cInput2
  1749.  
  1750. RETURN (type("cInput1") = type("cInput2")) .and. ;
  1751.        (m->cInput1 = m->cInput2) .and. (m->cInput2 = m->cInput1)
  1752. *-- EoF: ExEqual()
  1753.  
  1754. FUNCTION Str_Edit
  1755. *----------------------------------------------------------------------
  1756. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3232)
  1757. *-- Date........: 05/26/1992
  1758. *-- Notes.......: strips unwanted characters from a string
  1759. *--               (e.g. to normalize international phone numbers
  1760. *--               to nothing but numerals and "-")
  1761. *-- Written for.: dBASE IV 1.1+
  1762. *-- Rev. History: 01/01/1991 -- Original (Pete Carr)
  1763. *--               05/26/1992 -- Current
  1764. *-- Calls.......: None
  1765. *-- Called by...: Any
  1766. *-- Usage.......: valid required Str_Edit(<cInput>,<cBadChars>)
  1767. *-- Example.....: iphone = space(20)
  1768. *--               @ 6,12  say "Enter Phone# : " get iphone;
  1769. *--                       picture replicate("#",len(iphone));
  1770. *--                       valid required Str_Edit(iphone, " .+")
  1771. *--               input "011-(49)-345+6789-6790" 
  1772. *--               becomes "011-49-3456789-6790"
  1773. *-- Returns.....: .f., then .t.
  1774. *-- Parameters..: cInput    = input string
  1775. *--               cBadChars = excluded characters
  1776. *----------------------------------------------------------------------
  1777.  
  1778.    parameters cInput,cBadChars
  1779.    private lrv,nel,nsl,csc,nca,cInput,cBadChars
  1780.  
  1781.    lRV  = .t.                 && init return value to true
  1782.    nEL  = len(m->cBadChars)   && len of edit characters
  1783.    nSL  = len(m->cInput)      && len of string to edit
  1784.  
  1785.    cInput = trim(m->cInput)   && first, trim string to edit
  1786.  
  1787.    do while m->nEL > 0        && search string for cBadChars[el]
  1788.       cSC = substr(m->cBadChars, m->nEL, 1)
  1789.       do while .t.      && delete all cBadChars[el] contained in cInput
  1790.          nCA = at(m->cSC, m->cInput)
  1791.          if m->nCA > 0
  1792.             cInput = stuff(m->cInput, m->nCA, 1,"")
  1793.             lRV = .f.
  1794.             loop
  1795.          endif
  1796.          exit
  1797.       enddo
  1798.       nEL = m->nEL - 1
  1799.    enddo
  1800.  
  1801.    do while .t.           && search for double spaces and delete
  1802.       nCA = at("  ",m->cInput)
  1803.       if m->nCA > 0
  1804.          cInput = stuff(m->cInput, m->nCA, 1,"")
  1805.          lRV = .f.
  1806.       else
  1807.          exit
  1808.       endif
  1809.    enddo
  1810.  
  1811.    * restore string to original length
  1812.    cInput = m->cInput + space(m->nSL - len(m->cInput))
  1813.    if .not. m->lRV
  1814.       keyboard  chr(32) + chr(13)   && accept and display edited string
  1815.    endif
  1816.  
  1817. RETURN m->lRV
  1818. *-- EoF: Str_Edit
  1819.  
  1820. FUNCTION CapFirst
  1821. *-----------------------------------------------------------------------
  1822. *-- Programmer..: Peter Stevens (HMRS) CIS:100114,301
  1823. *--               Developed from a Borland Help Disk original
  1824. *-- Date........: 11/15/1993
  1825. *-- Notes.......: CAPITALizes a sentence with _some_ applied sense
  1826. *--               The list of words NOT to capitalize can be added to.
  1827. *--               The function was developed to test place names and
  1828. *--               will also work with 3 digits at start before a "The" 
  1829. *--               e.g. 123 the avenue comes out as 123 The Avenue but
  1830. *--               1234 the promenade comes out as 1234 the Promenade
  1831. *-- Written for.: dBASE IV 1.5 (All?)
  1832. *-- Rev. History: ??/??/?? - Original program
  1833. *--               11/15/1993 Much extended to test words NOT to 
  1834. *--                          capitalize
  1835. *-- Calls.......: None
  1836. *-- Called by...: Any
  1837. *-- Usage.......: CAPFIRST(cInString)
  1838. *-- Example.....: cADDR1 = CAPFIRST(cADDR1)
  1839. *-- Returns.....: cOutString
  1840. *-- Parameters..: text string to capitalize
  1841. *-----------------------------------------------------------------------
  1842.  
  1843.    parameters cInString
  1844.    private cInString, cOutString,cTalk,cTemp,nLength,nCount,lCap,;
  1845.            nTestLen, nCount,nSpaces
  1846.  
  1847.    *-- Check TALK is OFF 
  1848.    cTalk = set("TALK") 
  1849.    set talk off
  1850.  
  1851.    *-- Set up the variables
  1852.    store 1 to nCount,m->nSpaces
  1853.    m->lCap = .T.
  1854.    m->nTestLen = 1
  1855.    m->cInString = m->cInString+space(5)  && Note that cInString is 
  1856.                                          && NOT TRIMmed
  1857.    m->cOutString = ""                    && Trimming can have unwanted 
  1858.                                          && side effects
  1859.    m->nLength = LEN(m->cInString)        && especially if you want to 
  1860.                                          && edit it later
  1861.  
  1862.    *-- Start capfirsting
  1863.    do while m->nCount <= m->nLength
  1864.       m->cTemp = substr(m->cInString, m->nCount, 1)
  1865.  
  1866.       *-- If the character is already a CAP leave it be and go to 
  1867.       *-- the next
  1868.       if isupper("&cTemp.")
  1869.          m->cOutString = m->cOutString + upper(m->cTemp)
  1870.          m->nCount = m->nCount + 1
  1871.          m->lCap = .f.
  1872.          loop                               
  1873.       endif
  1874.  
  1875.       *-- if m->lCap = .t. the m->cTemp is to be a CAPITAL
  1876.    
  1877.       if m->lCap
  1878.          m->cOutString = m->cOutString + upper(m->cTemp)
  1879.          m->lCap = .F.
  1880.       else
  1881.          m->cOutString = m->cOutString + lower(m->cTemp)
  1882.       endif
  1883.       m->nCount = m->nCount + 1
  1884.  
  1885.      *-- Here is where its all decided - if the m->cTemp is a space or 
  1886.      *-- other chars shown between [ ] check what follows to test for 
  1887.      *-- words we don't want to capitalize.
  1888.  
  1889.      if m->cTemp $ [ (.-&",/:]
  1890.         m->lCap = .T.
  1891.         if m->cTemp $ [(- ]
  1892.            m->nTestLen = m->nLength - m->nCount
  1893.            if m->nTestLen < 1
  1894.               m->nTestLen = 2
  1895.            endif
  1896.            m->cTemp2 = substr(m->cInString,m->nCount,;
  1897.                             iif(m->nTestLen >= 4,4,m->nTestLen))
  1898.            do case
  1899.               case substr(m->cTemp2,1,2) = space(2) 
  1900.                    *-- Check to see if at end of the text - signified 
  1901.                    *-- by two spaces
  1902.                    if m->nCount >= 32    && Adjust this to the longest
  1903.                                          && textstring 
  1904.                       exit               && you are going to test
  1905.                    endif
  1906.  
  1907.               *-- Test for "a" or "y-" as in "Tyn-y-Gongl"
  1908.               case substr(m->cTemp2,1,2) $ "a y-"
  1909.                    m->cOutString = m->cOutString + ;
  1910.                                    lower(substr(m->cTemp2,1,1))
  1911.                    m->nCount = m->nCount + 1       
  1912.  
  1913.               *-- Test for two letter words and a space or dash
  1914.               case substr(m->cTemp2,1,3) $ ;
  1915.                    "an by en- in in- is le- op of on on- to " 
  1916.                    m->cOutString = m->cOutString + ;
  1917.                                    lower(substr(m->cTemp2,1,2))
  1918.                    m->nCount = m->nCount + 2
  1919.  
  1920.               *-- Test for the occurrence of "the" and its position in
  1921.               *-- the string Up to the 5th position it comes out as
  1922.               *-- "The"
  1923.               case substr(m->cTemp2,1,4) $ "the " .and. m->nCount <= 5
  1924.                    m->cOutString = m->cOutString + ;
  1925.                                    upper(substr(m->cTemp2,1,1))
  1926.                    m->cOutString = m->cOutString + ;
  1927.                                    lower(substr(m->cTemp2,2,2))
  1928.                    m->nCount = m->nCount + 3
  1929.  
  1930.               *-- Otherwise it comes out as "the"
  1931.               case substr(m->cTemp2,1,4) $ "the " .and. m->nCount > 5
  1932.                    m->cOutString = m->cOutString + ;
  1933.                                    lower(substr(m->cTemp2,1,3))
  1934.                    m->nCount = m->nCount + 3
  1935.  
  1936.               *-- Test for 3 letter words with a space or dash 
  1937.               *-- Or two letter words with a leading dash as in "Co-op"
  1938.               case substr(m->cTemp2,1,4) $ ;
  1939.                                       "-op cum cwm for and the- den-"
  1940.                    m->cOutString = m->cOutString + ;
  1941.                                       lower(substr(m->cTemp2,1,3))
  1942.                    m->nCount = m->nCount + 3
  1943.            endcase
  1944.          endif
  1945.       endif
  1946.    enddo
  1947.  
  1948.    *-- Organise the outstring for sending back
  1949.    m->cOutString = substr(m->cOutString,1,len(m->cInString)-4)
  1950.  
  1951.    *-- Reset Talk to previous setting
  1952.    set talk &cTalk.
  1953.  
  1954. RETURN m->cOutString
  1955. *-- EoF: CapFirst()
  1956.  
  1957. *----------------------------------------------------------------------
  1958. *-- EoP: STRINGS.PRG
  1959. *----------------------------------------------------------------------
  1960.